home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / FROMUTS / XLISP1 / !XLisp / c / XLJUMP < prev    next >
Text File  |  1990-02-23  |  3KB  |  138 lines
  1. /* xljump - execution context routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern CONTEXT *xlcontext;
  10. extern NODE *xlvalue;
  11. extern NODE ***xlstack,*xlenv;
  12. extern int xltrace,xldebug;
  13.  
  14. /* xlbegin - beginning of an execution context */
  15. xlbegin(cptr,flags,expr)
  16.   CONTEXT *cptr; int flags; NODE *expr;
  17. {
  18.     cptr->c_flags = flags;
  19.     cptr->c_expr = expr;
  20.     cptr->c_xlstack = xlstack;
  21.     cptr->c_xlenv = xlenv;
  22.     cptr->c_xltrace = xltrace;
  23.     cptr->c_xlcontext = xlcontext;
  24.     xlcontext = cptr;
  25. }
  26.  
  27. /* xlend - end of an execution context */
  28. xlend(cptr)
  29.   CONTEXT *cptr;
  30. {
  31.     xlcontext = cptr->c_xlcontext;
  32. }
  33.  
  34. /* xljump - jump to a saved execution context */
  35. xljump(cptr,type,val)
  36.   CONTEXT *cptr; int type; NODE *val;
  37. {
  38.     /* restore the state */
  39.     xlcontext = cptr;
  40.     xlstack = xlcontext->c_xlstack;
  41.     xlenv = xlcontext->c_xlenv;
  42.     xltrace = xlcontext->c_xltrace;
  43.     xlvalue = val;
  44.  
  45.     /* call the handler */
  46.     longjmp(xlcontext->c_jmpbuf,type);
  47. }
  48.  
  49. /* xltoplevel - go back to the top level */
  50. xltoplevel()
  51. {
  52.     findtarget(CF_TOPLEVEL,"no top level");
  53. }
  54.  
  55. /* xlcleanup - clean-up after an error */
  56. xlcleanup()
  57. {
  58.     findtarget(CF_CLEANUP,"not in a break loop");
  59. }
  60.  
  61. /* xlcontinue - continue from an error */
  62. xlcontinue()
  63. {
  64.     findtarget(CF_CONTINUE,"not in a break loop");
  65. }
  66.  
  67. /* xlgo - go to a label */
  68. xlgo(label)
  69.   NODE *label;
  70. {
  71.     CONTEXT *cptr;
  72.     NODE *p;
  73.  
  74.     /* find a tagbody context */
  75.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  76.     if (cptr->c_flags & CF_GO)
  77.         for (p = cptr->c_expr; consp(p); p = cdr(p))
  78.         if (car(p) == label)
  79.             xljump(cptr,CF_GO,p);
  80.     xlfail("no target for GO");
  81. }
  82.  
  83. /* xlreturn - return from a block */
  84. xlreturn(val)
  85.   NODE *val;
  86. {
  87.     CONTEXT *cptr;
  88.  
  89.     /* find a block context */
  90.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  91.     if (cptr->c_flags & CF_RETURN)
  92.         xljump(cptr,CF_RETURN,val);
  93.     xlfail("no target for RETURN");
  94. }
  95.  
  96. /* xlthrow - throw to a catch */
  97. xlthrow(tag,val)
  98.   NODE *tag,*val;
  99. {
  100.     CONTEXT *cptr;
  101.  
  102.     /* find a catch context */
  103.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  104.     if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
  105.         xljump(cptr,CF_THROW,val);
  106.     xlfail("no target for THROW");
  107. }
  108.  
  109. /* xlsignal - signal an error */
  110. xlsignal(emsg,arg)
  111.   char *emsg; NODE *arg;
  112. {
  113.     CONTEXT *cptr;
  114.  
  115.     /* find an error catcher */
  116.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  117.     if (cptr->c_flags & CF_ERROR) {
  118.         if (cptr->c_expr && emsg)
  119.         xlerrprint("error",NULL,emsg,arg);
  120.         xljump(cptr,CF_ERROR,NIL);
  121.     }
  122.     xlfail("no target for error");
  123. }
  124.  
  125. /* findtarget - find a target context frame */
  126. LOCAL findtarget(flag,error)
  127.   int flag; char *error;
  128. {
  129.     CONTEXT *cptr;
  130.  
  131.     /* find a block context */
  132.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  133.     if (cptr->c_flags & flag)
  134.         xljump(cptr,flag,NIL);
  135.     xlabort(error);
  136. }
  137.  
  138.